Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH4/SRC/COMPOSE3.FRM

Visual Basic Form | 1997-01-03 | 15.7 KB | 477 lines

VERSION 4.00
Begin VB.Form CompositeForm3
   Caption         =   "Composite3"
   ClientHeight    =   5895
   ClientLeft      =   1215
   ClientTop       =   585
   ClientWidth     =   6510
   Height          =   6300
   Left            =   1155
   LinkTopic       =   "Form1"
   ScaleHeight     =   393
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   434
   Top             =   240
   Width           =   6630
   Begin VB.PictureBox MaskPict
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   75
      Left            =   6120
      Picture         =   "COMPOSE3.frx":0000
      ScaleHeight     =   1
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   1
      TabIndex        =   5
      Top             =   480
      Visible         =   0   'False
      Width           =   75
   End
   Begin VB.PictureBox SourcePict
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   75
      Left            =   6120
      Picture         =   "COMPOSE3.frx":0446
      ScaleHeight     =   1
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   1
      TabIndex        =   4
      Top             =   0
      Visible         =   0   'False
      Width           =   75
   End
   Begin VB.PictureBox DisplaySwin
      Height          =   5655
      Left            =   0
      ScaleHeight     =   373
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   413
      TabIndex        =   2
      Top             =   0
      Width           =   6255
      Begin VB.PictureBox DisplayPict
         AutoRedraw      =   -1  'True
         Height          =   5535
         Left            =   0
         Picture         =   "COMPOSE3.frx":088C
         ScaleHeight     =   365
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   405
         TabIndex        =   3
         Top             =   0
         Width           =   6135
      End
   End
   Begin VB.HScrollBar DisplayHBar
      Enabled         =   0   'False
      Height          =   255
      Left            =   0
      TabIndex        =   1
      Top             =   5640
      Width           =   6285
   End
   Begin VB.VScrollBar DisplayVBar
      Enabled         =   0   'False
      Height          =   5655
      Left            =   6240
      TabIndex        =   0
      Top             =   0
      Width           =   255
   End
Attribute VB_Name = "CompositeForm3"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim SysPalSize As Integer
Dim NumStaticColors As Integer
Dim StaticColor1 As Integer
Dim StaticColor2 As Integer
Dim bytes_source() As Byte
Dim bytes_mask() As Byte
Dim wid(0 To 1) As Long
Dim hgt(0 To 1) As Long
Dim palentry(0 To 255) As PALETTEENTRY
' ************************************************
' Create and display the composite image.
' ************************************************
Public Sub MakeComposite()
Dim bound As Integer
Dim mid_weight As Integer
Dim x As Integer
Dim y As Integer
Dim black As Integer
Dim white As Integer
Dim status As Long
Dim i As Integer
Dim j As Integer
Dim kernel() As Single
Dim wgt As Single
Dim bytes_mask2() As Byte
Dim bytes_source2() As Byte
Dim bytes_source3() As Byte
Dim bytes_dest() As Byte
Dim r1 As Integer
Dim r2 As Integer
Dim dest_factor As Single
    WaitStart
    SourcePict.Visible = False
    MaskPict.Visible = False
    ' Show the user what's going on.
    DisplayPict.Move 0, 0, MaskPict.Width, MaskPict.Height
    DoEvents
    status = SetBitmapBits(DisplayPict.Image, wid(1) * hgt(1), bytes_mask(1, 1))
    DisplayPict.Refresh
    ' Step 1: Low pass filter the mask.
    ' Create a 5x5 low pass kernel.
    bound = 2
    mid_weight = 1
    ReDim kernel(-bound To bound, -bound To bound)
    For i = -bound To bound
        For j = -bound To bound
            kernel(i, j) = 1
        Next j
    Next i
    kernel(0, 0) = mid_weight
    wgt = (2 * bound + 1) * (2 * bound + 1) - 1 + mid_weight
    ' Apply the filter to the mask.
    ReDim bytes_mask2(1 To wid(1), 1 To hgt(1))
    For y = bound + 1 To hgt(1) - bound
        For x = bound + 1 To wid(1) - bound
            r1 = 0
            For i = -bound To bound
                For j = -bound To bound
                    r1 = r1 + kernel(i, j) * palentry(bytes_mask(x + i, y + j)).peRed
                Next j
            Next i
            r1 = r1 / wgt
            bytes_mask2(x, y) = NearestNonstaticGray(r1)
        Next x
    Next y
    ' Blank the edges of the mask.
    For y = 1 To hgt(1)
        For x = 1 To bound
            bytes_mask2(x, y) = white
            bytes_mask2(wid(1) - x + 1, y) = white
        Next x
    Next y
    For x = 1 To wid(1)
        For y = 1 To bound
            bytes_mask2(x, y) = white
            bytes_mask2(x, hgt(1) - y + 1) = white
        Next y
    Next x
    ' Show the user what's going on.
    status = SetBitmapBits(DisplayPict.Image, wid(1) * hgt(1), bytes_mask2(1, 1))
    DisplayPict.Refresh
    ' Copy the original image.
    ReDim bytes_source2(1 To wid(0), 1 To hgt(0))
    For x = 1 To wid(0)
        For y = 1 To hgt(0)
            bytes_source2(x, y) = bytes_source(x, y)
        Next y
    Next x

    ' Low pass filter the copy.
    ' (Reuse the same 5x5 low pass filter.)
    ' Apply the filter to the copy.
    ReDim bytes_source3(1 To wid(0), 1 To hgt(0))
    For y = bound + 1 To hgt(0) - bound
        For x = bound + 1 To wid(0) - bound
            r1 = 0
            For i = -bound To bound
                For j = -bound To bound
                    r1 = r1 + kernel(i, j) * palentry(bytes_source2(x + i, y + j)).peRed
                Next j
            Next i
            r1 = r1 / wgt
            bytes_source3(x, y) = NearestNonstaticGray(r1)
        Next x
    Next y
    ' Show the user what's going on.
    status = SetBitmapBits(DisplayPict.Image, wid(0) * hgt(0), bytes_source3(1, 1))
    DisplayPict.Refresh
    ' Take a weighted average of the original
    ' image and the low pass filtered version
    ' using the filtered mask.
    ReDim bytes_dest(1 To wid(0), 1 To hgt(0))
    For y = 1 To hgt(0)
        For x = 1 To wid(0)
            dest_factor = palentry(bytes_mask2(x, y)).peRed / 255#
            r1 = palentry(bytes_source(x, y)).peRed
            r2 = palentry(bytes_source3(x, y)).peRed
            bytes_dest(x, y) = NearestNonstaticGray((1 - dest_factor) * r1 + dest_factor * r2)
        Next x
    Next y
    ' Display the result.
    status = SetBitmapBits(DisplayPict.Image, wid(0) * hgt(0), bytes_dest(1, 1))
    DisplayPict.Refresh
    DisplayPict.Picture = DisplayPict.Image
    ResetScrollBars
    WaitEnd
    ' This will definitely take a long time so
    ' wake the user.
    Beep
End Sub
' ************************************************
' Return the index of the nonstatic gray closest
' to the given value (assuming the non-static
' colors are a gray scale created by
' MatchGrayPalette).
' ************************************************
Function NearestNonstaticGray(c As Integer) As Integer
Dim dgray As Single
    If c < 0 Then
        c = 0
    ElseIf c > 255 Then
        c = 255
    End If
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    NearestNonstaticGray = c / dgray + StaticColor1 + 1
End Function
' ***********************************************
' Load the indicated file and prepare to work
' with its palette.
' ***********************************************
Public Sub LoadFiles(source_name As String, mask_name As String)
Dim fname As String
Dim i As Integer
    WaitStart
    ' Create DisplayPict's palette.
    MatchGrayPalette 0, DisplayPict, bytes_source
    DoEvents    ' Don't be a total CPU hog.
    ' Load the source file.
    fname = source_name
    SourcePict.Move 0, 0
    SourcePict.Visible = True
    On Error GoTo LoadFileError
    SourcePict.Picture = LoadPicture(fname)
    On Error GoTo 0
    MatchGrayPalette 0, SourcePict, bytes_source
    DoEvents    ' Don't be a total CPU hog.
    ' Load the mask.
    fname = mask_name
    MaskPict.Move 0, 0
    MaskPict.Visible = True
    On Error GoTo LoadFileError
    MaskPict.Picture = LoadPicture(fname)
    On Error GoTo 0
    MatchGrayPalette 1, MaskPict, bytes_mask
    DoEvents    ' Don't be a total CPU hog.
    ' Rerealize each palette.
    SourcePict.ZOrder
    DoEvents
    MaskPict.ZOrder
    DoEvents
    WaitEnd
    Exit Sub
LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    WaitEnd
    Exit Sub
End Sub
' ***********************************************
' Load the control's palette so the non-static
' colors are grays. Map the logical palette to
' match the system palette. Convert the image to
' use the non-static grays.
' Set the following module global variables.
'   palentry()  Image logical palette entries.
'   wid         Width of image.
'   hgt         Height of image.
'   bytes(1 To wid, 1 To hgt)
'               Image pixel values.
' ***********************************************
Sub MatchGrayPalette(Index As Integer, pic As Control, bytes() As Byte)
Dim logpal As Integer
Dim sys(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim x As Integer
Dim y As Integer
Dim gray As Single
Dim dgray As Single
Dim c As Integer
Dim clr As Integer
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid(Index) = bm.bmWidthBytes
    hgt(Index) = bm.bmHeight
    ReDim bytes(1 To wid(Index), 1 To hgt(Index))
    status = GetBitmapBits(hbm, wid(Index) * hgt(Index), bytes(1, 1))
    ' Make the logical palette as big as possible.
    logpal = pic.Picture.hPal
    If ResizePalette(logpal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        palentry(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        palentry(i) = sys(i)
    Next i
    i = SetPaletteEntries(logpal, 0, SysPalSize, palentry(0))
    ' Insert the non-static grays.
    gray = 0
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    For i = StaticColor1 + 1 To StaticColor2 - 1
        c = gray
        gray = gray + dgray
        With palentry(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    i = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
    ' Recreate the image using the new colors.
    For y = 1 To hgt(Index)
        For x = 1 To wid(Index)
            clr = bytes(x, y)
            With sys(clr)
                c = (CInt(.peRed) + .peGreen + .peBlue) / 3
            End With
            bytes(x, y) = NearestNonstaticGray(c)
        Next x
    Next y
    status = SetBitmapBits(hbm, wid(Index) * hgt(Index), bytes(1, 1))
    ' Realize the gray palette.
    i = RealizePalette(pic.hdc)
    pic.Refresh
End Sub
' ***********************************************
' Set the Max and LargeChange properties for the
' image scroll bars.
' ***********************************************
Sub ResetScrollBars()
    ' DisplayHBar.
    DisplayHBar.Value = 0
    If DisplaySwin.ScaleWidth >= DisplayPict.Width Then
        DisplayHBar.Enabled = False
    Else
        DisplayHBar.Max = DisplayPict.Width - DisplaySwin.ScaleWidth
        DisplayHBar.LargeChange = DisplaySwin.ScaleWidth
        DisplayHBar.Enabled = True
    End If
    ' DisplayVBar.
    DisplayVBar.Value = 0
    If DisplaySwin.ScaleHeight >= DisplayPict.Height Then
        DisplayVBar.Enabled = False
    Else
        DisplayVBar.Max = DisplayPict.Height - DisplaySwin.ScaleHeight
        DisplayVBar.LargeChange = DisplaySwin.ScaleHeight
        DisplayVBar.Enabled = True
    End If
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    DisplayPict.MousePointer = vbHourglass
    SourcePict.MousePointer = vbHourglass
    MaskPict.MousePointer = vbHourglass
    DoEvents
End Sub
' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    DisplayPict.MousePointer = vbDefault
    SourcePict.MousePointer = vbDefault
    MaskPict.MousePointer = vbDefault
End Sub
Private Sub Form_Load()
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If
    ' Get system palette size and # static colors.
    SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
    NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
    StaticColor1 = NumStaticColors \ 2 - 1
    StaticColor2 = SysPalSize - NumStaticColors \ 2
    ' Remove the borders from DisplayPict.
    DisplayPict.BorderStyle = vbTransparent
    SourcePict.BorderStyle = vbTransparent
    MaskPict.BorderStyle = vbTransparent
End Sub
' ***********************************************
' Make the picture as large as possible.
' ***********************************************
Private Sub Form_Resize()
Dim hgt As Single
Dim wid As Single
    If WindowState = vbMinimized Then Exit Sub

    hgt = ScaleHeight - DisplayHBar.Height - 1
    wid = ScaleWidth - DisplayVBar.Width - 1
    ' Place the controls.
    DisplaySwin.Move 0, 0, wid, hgt
    DisplayVBar.Move _
        DisplaySwin.Left + DisplaySwin.Width + 1, _
        0, DisplayVBar.Width, hgt
    DisplayHBar.Move _
        DisplaySwin.Left, DisplaySwin.Height + 1, _
        wid
    ' Set the scroll bar limits.
    ResetScrollBars
End Sub
' ***********************************************
' Move DisplayPict within DisplaySwin.
' ***********************************************
Private Sub DisplayHBar_Change()
    DisplayPict.Left = -DisplayHBar.Value
End Sub
' ***********************************************
' Move DisplayPict within DisplaySwin.
' ***********************************************
Private Sub DisplayHBar_Scroll()
    DisplayPict.Left = -DisplayHBar.Value
End Sub
' ***********************************************
' Move DisplayPict within DisplaySwin.
' ***********************************************
Private Sub DisplayVBar_Change()
    DisplayPict.Top = -DisplayVBar.Value
End Sub
' ***********************************************
' Move DisplayPict within DisplaySwin.
' ***********************************************
Private Sub DisplayVBar_Scroll()
    DisplayPict.Top = -DisplayVBar.Value
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub